home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-2 / Inter.Net 55-2.iso / Mandrake / mdkinst / usr / lib / perl5 / 5.00503 / SelfLoader.pm < prev    next >
Encoding:
Perl POD Document  |  2000-01-12  |  3.8 KB  |  105 lines
  1. package SelfLoader;
  2. use Carp;
  3. require Exporter;
  4. @ISA = qw(Exporter);
  5. @EXPORT = qw(AUTOLOAD);
  6. $VERSION = "1.08";
  7. sub Version {$VERSION}
  8. $DEBUG = 0;
  9.  
  10. my %Cache;      # private cache for all SelfLoader's client packages
  11.  
  12. AUTOLOAD {
  13.     print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if $DEBUG;
  14.     my $SL_code = $Cache{$AUTOLOAD};
  15.     unless ($SL_code) {
  16.         # Maybe this pack had stubs before __DATA__, and never initialized.
  17.         # Or, this maybe an automatic DESTROY method call when none exists.
  18.         $AUTOLOAD =~ m/^(.*)::/;
  19.         SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::<DATA"};
  20.         $SL_code = $Cache{$AUTOLOAD};
  21.         $SL_code = "sub $AUTOLOAD { }"
  22.             if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/);
  23.         croak "Undefined subroutine $AUTOLOAD" unless $SL_code;
  24.     }
  25.     print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if $DEBUG;
  26.     eval $SL_code;
  27.     if ($@) {
  28.         $@ =~ s/ at .*\n//;
  29.         croak $@;
  30.     }
  31.     defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
  32.     delete $Cache{$AUTOLOAD};
  33.     goto &$AUTOLOAD
  34. }
  35.  
  36. sub load_stubs { shift->_load_stubs((caller)[0]) }
  37.  
  38. sub _load_stubs {
  39.     my($self, $callpack) = @_;
  40.     my $fh = \*{"${callpack}::DATA"};
  41.     my $currpack = $callpack;
  42.     my($line,$name,@lines, @stubs, $protoype);
  43.  
  44.     print STDERR "SelfLoader::load_stubs($callpack)\n" if $DEBUG;
  45.     croak("$callpack doesn't contain an __DATA__ token")
  46.         unless fileno($fh);
  47.     $Cache{"${currpack}::<DATA"} = 1;   # indicate package is cached
  48.  
  49.     local($/) = "\n";
  50.     while(defined($line = <$fh>) and $line !~ m/^__END__/) {
  51.         if ($line =~ m/^sub\s+([\w:]+)\s*(\([\\\$\@\%\&\*\;]*\))?/) {
  52.             push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
  53.             $protoype = $2;
  54.             @lines = ($line);
  55.             if (index($1,'::') == -1) {         # simple sub name
  56.                 $name = "${currpack}::$1";
  57.             } else {                            # sub name with package
  58.                 $name = $1;
  59.                 $name =~ m/^(.*)::/;
  60.                 if (defined(&{"${1}::AUTOLOAD"})) {
  61.                     \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
  62.                         die 'SelfLoader Error: attempt to specify Selfloading',
  63.                             " sub $name in non-selfloading module $1";
  64.                 } else {
  65.                     $self->export($1,'AUTOLOAD');
  66.                 }
  67.             }
  68.         } elsif ($line =~ m/^package\s+([\w:]+)/) { # A package declared
  69.             push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
  70.             $self->_package_defined($line);
  71.             $name = '';
  72.             @lines = ();
  73.             $currpack = $1;
  74.             $Cache{"${currpack}::<DATA"} = 1;   # indicate package is cached
  75.             if (defined(&{"${1}::AUTOLOAD"})) {
  76.                 \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
  77.                     die 'SelfLoader Error: attempt to specify Selfloading',
  78.                         " package $currpack which already has AUTOLOAD";
  79.             } else {
  80.                 $self->export($currpack,'AUTOLOAD');
  81.             }
  82.         } else {
  83.             push(@lines,$line);
  84.         }
  85.     }
  86.     close($fh) unless defined($line) && $line =~ /^__END__\s*DATA/;     # __END__
  87.     push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
  88.     eval join('', @stubs) if @stubs;
  89. }
  90.  
  91.  
  92. sub _add_to_cache {
  93.     my($self,$fullname,$pack,$lines, $protoype) = @_;
  94.     return () unless $fullname;
  95.     carp("Redefining sub $fullname") if exists $Cache{$fullname};
  96.     $Cache{$fullname} = join('', "package $pack; ",@$lines);
  97.     print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if $DEBUG;
  98.     # return stub to be eval'd
  99.     defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;"
  100. }
  101.  
  102. sub _package_defined {}
  103.  
  104. 1;
  105.